home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops ƒ / Args next >
Text File  |  1995-11-17  |  7KB  |  282 lines
  1. \ Support for named parms and local variables
  2.  
  3. cr .( loading Args...)
  4.  
  5.    24    constant    MAXPL        \ Should be enough!!
  6. false    value        LOCFLG        \ true = looking for local var tokens
  7.  
  8.  
  9. create    PARMLIST    maxPL cells  reserve
  10.  
  11.     0    value    SVHASH
  12. false    value    FLOAT?
  13.     0    value    PLentry_addr
  14.  
  15.  
  16. : INITLOCS        \ Initializes flags etc.
  17.     0 -> #PL  0 -> #P  0 -> #F
  18.     0 -> FltFlg  false -> locFlg  ;
  19.  
  20.  
  21. : FINDINPARMLIST        \ ( addr -- loc# T  OR  -- F )
  22.             \ loc# counts from right to left in the local/parm list.
  23.  
  24.     dup 1+ c@   & %  =  -> float?
  25.     hash -> svHash  false
  26.     #PL  0exit
  27.     ParmList  #PL 4*  bounds  DO
  28.         svHash  i @ =
  29.         IF  ( found )
  30.             drop  #PL
  31.             i parmlist -  4/
  32.             -  1-  true  LEAVE
  33.         THEN
  34.     4 +LOOP  ;
  35.  
  36.  
  37. : ADDTOPARMLIST        \ ( addr -- )  Adds an element to ParmList.
  38.                     \  addr points to a counted string.
  39.     findinParmList  ?error 95        \ Name not unique
  40.     #PL  maxPL  >=  ?error 110
  41.     FltFlg  1 <<   float? if  1 or  1 ++> #F  then  -> FltFlg
  42.     svHash
  43.     #PL  1 ++> #PL  4*  ParmList +  !  ;
  44.  
  45.  
  46. : FIRSTCHR
  47.     here 1+ c@  ;
  48.  
  49.  
  50. :f {
  51.     local? IF            \ local? already non-zero - this ought to mean we're
  52.                         \  in a local section
  53.         local? 0< ?error 92  -1 -> local?
  54.     THEN
  55.     initLocs
  56.     
  57.     BEGIN                    \ Loop to add parms/locals to parmlist
  58.         Mword drop
  59.         firstChr  & -  <>            \ look for --
  60.     WHILE
  61.         firstChr dup  & \  =  swap  & /  =  or
  62.                 \ Note: we allow / as an alternative to \
  63.  
  64.         IF        true -> locFlg
  65.         ELSE    firstChr  & } =  ?error 111
  66.             locFlg nif  1 ++> #P  then
  67.             here  AddToParmList
  68.         THEN
  69.     REPEAT
  70.     local? NIF                        \ In local sections, we do this at :LOC
  71.         here  -> PLentry_addr
  72.             \  If we have temp objects, we'll have to backup the DP and
  73.             \  recompile the entry sequence, since there'll be an extra local
  74.             \  (the frame pointer)
  75.         PLentry
  76.     THEN
  77.     & }  parse 2drop                \ eat characters until }
  78.     rest nip  0< ?error 112  ;f        \ Err if no final }
  79.  
  80.  
  81. \ FIND will call Pfind to attempt to find a name first.
  82. \ If Pfind finds the name is a local, it returns true and the
  83. \ cfa of LocParm, which is a dummy word whose handler compiles
  84. \ a local reference.
  85.  
  86. : PFIND        \ ( str-addr -- cfa T  |  -- str-addr F )
  87.     state
  88.     NIF        false
  89.     ELSE    dup  FindInParmList
  90.         IF                        \ Found
  91.             -> loc#  drop
  92.             float? IF  ['] FlocParm  ELSE  ['] locParm  THEN
  93.             true
  94.         ELSE    false            \ Not found
  95.         THEN
  96.     THEN   ;
  97.  
  98.  
  99. : ,EXEC        \ ( cfa n -- )
  100.     state
  101.     IF  (compN)  ELSE  exN  THEN  ;
  102.  
  103. \ Here are the different types that we can put prefixes on or send
  104. \ messages to:
  105.  
  106. TYPE{    notfnd  locTyp  flocTyp
  107.         tmpObjTyp  objTyp  ivarTyp  classTyp  superTyp
  108.         valTyp  fvalTyp  vecTyp  dynVecTyp  objptrTyp
  109.         regTyp  lbTyp  lbSelfTyp  bktTyp  wordTyp  }
  110.  
  111. \ notFnd    - not previously defined
  112. \ locTyp    - a local or named parm
  113. \ tmpObjTyp    - a temporary (local) object
  114. \ objTyp    - an object
  115. \ ivarTyp    - an ivar
  116. \ classTyp    - a class
  117. \ superTyp    - a named superclass specified by  msg: super> someClass
  118. \ valTyp    - a value
  119. \ FvalTyp    - a floating point value
  120. \ vecTyp    - a vector
  121. \ dynVecTyp    - a dynamic vector
  122. \ regTyp    - a 680x0 register
  123. \ lbTyp        - ** or [] meaning late bind
  124. \ lbSelfTyp    - [self] meaning late bind to self
  125. \ BktTyp    - [ - Neon-compatible late bind
  126. \ wordTyp    - a word
  127.  
  128. \ PRFTOKEN returns the type of a token for a prefix op.
  129.  
  130. \ First we need to make some handler codes available above the Nucleus.
  131.  
  132. : HDLR        \ ( cfa -- ha )
  133.     2- w@x  ;
  134.  
  135. ' key    hdlr    constant    VECTCODE
  136. ' base    hdlr    constant    VALCODE
  137. ' ^base    hdlr    constant    REGCODE
  138. ' hdlr    hdlr    constant    WORDCODE
  139.  
  140.     objPtr XX          ' xx  hdlr        forget xx
  141.                 constant    OBJPTRCODE
  142.     dynamicVect XX    ' xx  hdlr        forget xx
  143.                 constant    DYNVECTCODE
  144.  
  145. : PRFTOKEN    \ ( -- cfa type )
  146.     '  dup  ['] locParm  =  IF  locTyp    EXIT  THEN
  147.        dup  ['] FlocParm =  IF  FlocTyp    EXIT  THEN
  148.     dup  hdlr
  149.     CASE
  150.         valCode        OF    valTyp        ENDOF
  151.         FvalCode    OF    FvalTyp        ENDOF
  152.         vectCode    OF    vecTyp        ENDOF
  153.         dynVectCode    OF    dynVecTyp    ENDOF
  154.         regCode        OF    regTyp        ENDOF
  155.         objPtrCode    OF    objPtrTyp    ENDOF
  156.         114 die
  157.     ENDCASE  ;
  158.  
  159.  
  160. forward    ToObjPtr        \ Stores to an objPtr.  Defined in file Class.
  161.  
  162. : ->        immediate
  163.     PrfToken                \ All types are legal
  164.     objPtrTyp =  IF  toObjPtr  EXIT  THEN
  165.     $ 60  ( opcode for Store )  ,exec  ;
  166.                         \ NOTE: opcode for store hard coded here!!!
  167.  
  168. : CvrtFcode    \ ( code -- code' )
  169.     CASE
  170.         $ 21  OF  $ 41  ENDOF        \ +
  171.         $ 22  OF  $ 48  ENDOF        \ -
  172.         $ 28  OF  $ 55  ENDOF        \ Neg
  173.         ?error 114
  174.     ENDCASE  ;
  175.  
  176. : (+->)        \ ( code -- cfa code' )
  177.     PrfToken ( code cfa type )  rot swap ( cfa code type )
  178.     
  179.     CASE
  180.         locTyp        OF                ENDOF
  181.         FlocTyp        OF  cvrtFcode    ENDOF
  182.         valTyp        OF                ENDOF
  183.         FvalTyp        OF  cvrtFcode    ENDOF
  184.         regTyp        OF                ENDOF
  185.         ?error 114
  186.     ENDCASE  ;
  187.  
  188. : (FOP)
  189.     PrfToken  rot swap
  190.     CASE
  191.         locTyp        OF  ENDOF
  192.         FlocTyp        OF  ENDOF
  193.         FvalTyp        OF  ENDOF
  194.         ?error 114
  195.     ENDCASE  ;
  196.  
  197. \ Note: the following opcodes have to agree with the definitions in
  198. \ OD.asm.  I could have defined them as constants but this would have
  199. \ used up dictionary space for no great benefit.
  200.  
  201. : ++>    $ 21  (+->)  ,exec  ;        immediate
  202. : +>    postpone  ++>       ;        immediate        \ A synonym.
  203. : -->    $ 22  (+->)  ,exec  ;        immediate
  204. : AND>    $ 23  (+->)  ,exec  ;        immediate
  205. : OR>    $ 24  (+->)  ,exec  ;        immediate
  206. : XOR>    $ 25  (+->)  ,exec  ;        immediate
  207. : NEG>    $ 28  (+->)  ,exec  ;        immediate
  208. : NOT>    $ 29  (+->)  ,exec  ;        immediate
  209. : *>    $ 42  (fop)  ,exec  ;        immediate
  210. : />    $ 49  (fop)  ,exec  ;        immediate
  211. : ABS>    $ 54  (fop)  ,exec  ;        immediate
  212.  
  213. ' Pfind  -> Ufind
  214.  
  215. \         =========== Local sections ===========
  216.  
  217. forward        INITTEMPS
  218.  
  219. : ?LOC    local? 0=  ?error 91  ;            \ "We're not in a local section"
  220.  
  221. : LOCAL
  222.     local?  ?error 93  1 -> local?        \ We change it to the normal -1
  223.                                         \ as soon as "{" is read.
  224.     forward  ;
  225.  
  226.  
  227. : :LOC        immediate
  228.     local? 1 = IF  msg# 96  THEN        \ warning  - no locals defined
  229.     ?loc  304
  230.     here  '  (patch)  :noname            \ Like :F
  231.     #PL  IF  PLentry  THEN
  232.     frameSize IF  initTemps  THEN
  233.     false -> local?                \ We do this here so any EXITs
  234. ;                                \  tidy everything up properly
  235.  
  236.  
  237. : ;LOC        immediate
  238.     (;)  304 ?defn  ;        \ As local? is now false, everything else
  239.                             \ gets tidied up by (;)
  240.  
  241.  
  242. \            ============================================
  243.  
  244. : EVALUATE  { addr len \ x1 x2 x3 x4 -- ?? }
  245.  
  246.     save-input  drop            \ Must be 4
  247.     -> x4 -> x3 -> x2 -> x1        \ Move input-stream specs to locals
  248.  
  249.     addr -> src-start  len -> src-len  0 >in !  -1 -> source-id
  250.     echo?  IF  ." ***evaluating***  "  addr len type cr  THEN
  251.     interpret
  252.     x1 x2 x3 x4  4  restore-input  ?error 25  ;
  253.  
  254. \ We can EVALUATE strings which might have embedded returns, and we can't
  255. \ just convert returns to blanks since we want the comment operator \
  256. \ to only skip to the end of the line, not the end of the string.  We handle
  257. \ this by defining an immediate "word" which just consists of a return, which
  258. \ does nothing.  We initially define it as X then patch it.  Our dic
  259. \ threading scheme doesn't clobber this since we just hash on the length,
  260. \ which remains 1.
  261.  
  262. : X        ;  immediate
  263.  
  264. 13 ( cr )   ' x  >name 1+  c!
  265.  
  266.  
  267. : (COMPINL)    \ ( cfa -- )
  268.     2+ count  evaluate  ;
  269.  
  270. ' (compinl) -> compinline
  271.  
  272. : INLINE{        immediate
  273.     method? IF  -4 allot  THEN        \ Wipe out method entry sequence
  274.                                     \ %%% watch this on PPC!
  275.     inlMk w,  & }  ,str
  276.     align-dp
  277.     method? IF  Mentry  THEN        \ Recompile method entry sequence
  278.     postpone ]  ;
  279.  
  280.  
  281. load class
  282.